home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-04 / forthcmp.zip / FIND.4TH < prev    next >
Text File  |  1992-03-30  |  6KB  |  258 lines
  1. \ FIND PROGRAM, BY TOM ALMY.
  2.  
  3. \ THIS PROGRAM IS COPYRIGHT (C) 1985 BY TOM ALMY,
  4. \ ALL RIGHTS RESERVED.
  5.  
  6. \  Users of ForthCMP are given permission to use or distribute this
  7. \  program, as long as no charge is made and the credit message is maintained.
  8.  
  9.  
  10. 100 MSDOS
  11. INCLUDE VARS
  12. INCLUDE DOS1
  13.  
  14. 0 0 IN/OUT NEED HELP-ME
  15.  
  16. \ KEY -- FROM A FILE
  17.  
  18. 32768 CONSTANT INBUFSZ
  19. 128 CONSTANT SCRATCH_BUF
  20. HCB INFILE            \ File being read
  21. 10000 CONSTANT INBUFFER        \ Buffer for input file in high memory
  22. VARIABLE INBUFPTR        \ Pointer to next character in buffer
  23. VARIABLE INBUFEND        \ End of buffer
  24.  
  25. : KEY  
  26.     INBUFPTR @ INBUFEND @ = IF ( fetch block )
  27.     INFILE INBUFFER INBUFSZ FREAD ?DUP IF ( everything OK )
  28.         INBUFFER INBUFPTR !     
  29.         INBUFFER + INBUFEND !
  30.     ELSE 
  31.         CONTROL Z EXIT 
  32.     THEN
  33.     THEN
  34.     INBUFPTR @ C@ 127 AND
  35.     1 INBUFPTR +! ;
  36.  
  37. \ DIRECTORY SEARCHING STUFF
  38.  
  39. 256 CONSTANT LINBUFSIZE        \ Lines should not be longer than this
  40. CREATE LINEBUF    LINBUFSIZE ALLOT
  41. CREATE MATCHBUF 128 ALLOT 
  42. CREATE UCMATCHBUF 128 ALLOT    \ upcased version of above )
  43. VARIABLE NEXTITEM        \ must scan for new wildcard file name
  44. HCB WILDFILE            \ possibly wildcarded file name
  45. VARIABLE INFILEP        \ just a pointer
  46. VARIABLE /PNTR            \ location of last / or \
  47. 0 EQU NEWFILE?            \ new file
  48.  
  49. 2 1 IN/OUT
  50. : PROCESS-WORD ( destAddr srcaddr -- newdestaddr )
  51.     BEGIN #TIB @ >IN @ > WHILE   \ more characters to process
  52.         DUP C@ BL = IF DROP EXIT THEN \ found blank -- quit
  53.     DUP C@ ASCII \ = IF 1+ 1 >IN +! THEN \ quote next character
  54.         2DUP C@ SWAP C!
  55.         1+ SWAP 1+ SWAP 1 >IN +!
  56.     REPEAT
  57.     DROP \ reached end (bad news), we are finished 
  58. ;
  59.  
  60. 2 2 IN/OUT
  61. : SEEK-START ( destAddr srcAddr -- destAddr newSrcAddr )
  62.     BEGIN #TIB @ >IN @ > WHILE \ more characters to process
  63.         DUP C@ BL = IF  1+  1 >IN +!
  64.             ELSE  EXIT THEN
  65.     REPEAT \ BAD NEWS IF FINISHES
  66. ;      
  67.  
  68.  
  69. 0 1 IN/OUT 
  70. : NICE-WORD ( -- addr )
  71.     DP @  1+ TIB >IN @ +  \ destAddr srcAddr
  72.     SEEK-START
  73.     PROCESS-WORD
  74.     DP @ 1+ - \ length of match string
  75.     DP @ C!     \ gets stored at start
  76.     DP @ 
  77. ;
  78.  
  79.  
  80. 0 0 IN/OUT
  81. : PARSE-COMMAND-LINE  ( -- )
  82.    128 1+ TIB 127 CMOVE 
  83.    128 C@ #TIB !
  84.    >IN OFF
  85.    NEXTITEM ON
  86.    NICE-WORD COUNT DUP 0= IF HELP-ME THEN ( NO ARGUMENTS )
  87.    MATCHBUF SWAP CMOVE    ( MOVE IN MATCH STRING )
  88.    128 0 DO MATCHBUF I + C@ DUP ASCII a >= IF DUP ASCII z <= 
  89.                           IF 32 - THEN THEN
  90.         UCMATCHBUF I + C! LOOP   ( fill uppercase buffer )
  91.    ;
  92.  
  93.  
  94. 1 0 IN/OUT 
  95. : PUTN ( character -- , put in string of INFILE )
  96.    INFILEP @ C! 1 INFILEP +! ;
  97.  
  98.  
  99. 0 0 IN/OUT
  100. : MAKE-FILENAME \ set up INFILE with path from WILDFILE and
  101.         \ file name from SCRATCH_BUF
  102.     INFILE 3 + INFILEP ! \ address of destination string
  103.     INFILEP @  /PNTR !  \ location of last slash 
  104.     WILDFILE 2+ COUNT 0 ?DO COUNT DUP PUTN 
  105.          DUP ASCII \ = OVER ASCII : = OR SWAP ASCII / = OR IF 
  106.             INFILEP @ /PNTR ! THEN 
  107.     LOOP
  108.     DROP ( wildfile pointer )
  109.     /PNTR @ INFILEP !    \ get rid of characters after last \
  110.     SCRATCH_BUF 30 + \ remainder of filename
  111.     BEGIN COUNT DUP WHILE PUTN REPEAT 2DROP
  112.     INFILEP @ INFILE 3 + - INFILE 2 + C! \ length
  113.     0 PUTN \ zero delimit string
  114.     ;
  115.  
  116.  
  117. 0 1 IN/OUT 
  118. : NEW-FILE? ( -- success )
  119.   BEGIN NEXTITEM @ IF ( must scan input stream )
  120.     BL WORD DUP C@ 0= IF DROP 0 EXIT THEN ( End of line )
  121.     WILDFILE NAME>HCB
  122.     WILDFILE HCB>N 0 firstf
  123.     NEXTITEM OFF 
  124.       ELSE
  125.     nextf 
  126.       THEN 
  127.     WHILE ( search failed )
  128.       NEXTITEM ON
  129.     REPEAT
  130.   MAKE-FILENAME
  131.   INFILE O_RD FOPEN IF MESSAGES CR 
  132.     ." OPEN FAILED FOR " INFILE .FNAME CONSOLE
  133.     NEW-FILE? EXIT THEN
  134.   INBUFEND @ INBUFPTR !     ( force first read )
  135.   -1 ( SUCCESS! )   ;
  136.  
  137.  
  138. 0 0 IN/OUT
  139. : CLOSE-THE-FILE  INFILE FCLOSE DROP ;
  140.  
  141.  
  142.  
  143. \ Messages
  144.  
  145.  
  146. 0 0 IN/OUT
  147. : PRINT-SEARCHING ( --- )
  148.     NEWFILE? IF
  149.         CR ." Searching " INFILE .FNAME 
  150.         0 EQU NEWFILE?
  151.     THEN 
  152. ;
  153.  
  154. 0 0 IN/OUT
  155. : HELLO
  156.     MESSAGES
  157.     ." Search Program.  Copyright (C) 1985 by Tom Almy" CR
  158.     CONSOLE
  159. ;
  160.  
  161. 0 0 IN/OUT
  162. : HELP-ME
  163.     MESSAGES
  164.     ." Usage: FIND string {filenames}" CR
  165.     ." String escape character is \" CR
  166.     bye
  167. ;  
  168.  
  169.  
  170.  
  171.  
  172. \ Searching functions
  173.  
  174.  
  175.  
  176. VARIABLE LINE#
  177.  
  178. VARIABLE ^LINE
  179.  
  180. 0 0 IN/OUT
  181. : CLEAR-LINE   LINEBUF ^LINE ! ;
  182.  
  183. 1 0 IN/OUT 
  184. : PUT-LINE ( char -- ) 
  185.   LINEBUF LINBUFSIZE + ^LINE @ = IF 
  186.     MESSAGES CR ." LINE TOO LONG!" CLEAR-LINE CONSOLE THEN
  187.   ^LINE @ C!  1 ^LINE +! ;
  188.  
  189. 10 CONSTANT aLF
  190. 13 CONSTANT aCR
  191.  9 CONSTANT aTAB
  192.  
  193. 0 0 IN/OUT
  194. : PRINT-TO-EOL
  195.     BEGIN 
  196.     KEY DUP aLF <> OVER CONTROL Z <> AND 
  197.     WHILE 
  198.     DUP aCR = IF DROP ELSE EMIT THEN
  199.     REPEAT
  200.     DROP ;
  201.  
  202. 0 0 IN/OUT
  203. : SEARCHING   
  204.    -1 EQU NEWFILE?
  205.    1 LINE# !
  206.    CLEAR-LINE
  207.    UCMATCHBUF COUNT
  208.    MATCHBUF COUNT  ( first char on top of stack, bufferaddr under )
  209.    BEGIN KEY  CASE
  210.     aLF OF  CLEAR-LINE  2DROP 2DROP            \ lf
  211.          UCMATCHBUF COUNT MATCHBUF COUNT 
  212.          1 LINE# +! ENDOF                 
  213.      \ stack has ucbufaddr char bufaddr char key
  214.     OVER  OF                    \ CHARACTER MATCHES
  215.          PUT-LINE  NIP SWAP COUNT ROT COUNT 
  216.            DUP 0= IF   2DROP 2DROP     \ COMPLETE MATCH       
  217.          PRINT-SEARCHING
  218.          CR  LINE# @ 4 .R SPACE
  219.          LINEBUF ^LINE @ LINEBUF - TYPE
  220.          PRINT-TO-EOL
  221.          CLEAR-LINE  
  222.          UCMATCHBUF COUNT MATCHBUF COUNT THEN     
  223.         ENDOF
  224.      \ stack has ucbufaddr char bufaddr char key
  225.     3 PICK  OF                 \ UPPERCASE CHARACTER MATCHES
  226.          ROT PUT-LINE  DROP SWAP COUNT ROT COUNT 
  227.            DUP 0= IF   2DROP 2DROP     \ COMPLETE MATCH       
  228.          PRINT-SEARCHING
  229.          CR  LINE# @ 4 .R SPACE
  230.          LINEBUF ^LINE @ LINEBUF - TYPE
  231.          PRINT-TO-EOL
  232.          CLEAR-LINE  
  233.          UCMATCHBUF COUNT MATCHBUF COUNT THEN     
  234.         ENDOF
  235.     CONTROL Z OF  2DROP 2DROP  EXIT ENDOF        \ END OF FILE
  236.     PUT-LINE 2DROP 2DROP                \ NO MATCH
  237.     UCMATCHBUF COUNT MATCHBUF COUNT    0   
  238.      ENDCASE
  239.    AGAIN \ REPEAT FOREVER
  240.    ;
  241.     
  242.  
  243.  
  244. \ MAIN LOOP
  245. : MAIN
  246.     HELLO
  247.     PARSE-COMMAND-LINE
  248.     BEGIN 
  249.     NEW-FILE? WHILE
  250.     SEARCHING 
  251.     CLOSE-THE-FILE
  252.     REPEAT ;
  253.  
  254. INCLUDE DOS2
  255. INCLUDE FORTHLIB
  256. END
  257.  
  258.